home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / xnum.scm < prev    next >
Text File  |  1995-10-13  |  9KB  |  293 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; This is file xnum.scm.
  4.  
  5. ;;;; Extended number support
  6.  
  7. (define-simple-type :extended-number (:number) extended-number?)
  8.  
  9. (define-record-type extended-number-type :extended-number-type
  10.   (really-make-extended-number-type field-names supers priority predicate id)
  11.   extended-number-type?
  12.   (field-names extended-number-type-field-names)
  13.   (supers      extended-number-type-supers)
  14.   (priority    extended-number-type-priority)
  15.   (predicate   extended-number-predicate)
  16.   (id           extended-number-type-identity))
  17.  
  18. (define (make-extended-number-type field-names supers id)
  19.   (letrec ((t (really-make-extended-number-type
  20.            field-names
  21.            supers
  22.            (+ (apply max
  23.              (map type-priority
  24.                   (cons :extended-number supers)))
  25.           10)
  26.            (lambda (x)
  27.          (and (extended-number? x)
  28.               (eq? (extended-number-type x) t)))
  29.            id)))
  30.     t))
  31.  
  32. (define (extended-number-type x) (extended-number-ref x 0))
  33.  
  34.  
  35. ; DEFINE-EXTENDED-NUMBER-TYPE macro
  36.  
  37. (define-syntax define-extended-number-type
  38.   (syntax-rules ()
  39.     ((define-extended-number-type ?type (?super ...)
  40.        (?constructor ?arg1 ?arg ...)
  41.        ?predicate
  42.        (?field ?accessor)
  43.        ...)
  44.      (begin (define ?type
  45.           (make-extended-number-type '(?field ...)
  46.                      (list ?super ...)
  47.                      '?type))
  48.         (define ?constructor
  49.           (let ((args '(?arg1 ?arg ...)))
  50.         (if (equal? args
  51.                 (extended-number-type-field-names ?type))
  52.             (let ((k (+ (length args) 1)))
  53.               (lambda (?arg1 ?arg ...)
  54.             (let ((n (make-extended-number k #f))
  55.                   (i 1))
  56.               (extended-number-set! n 0 ?type)
  57.               (extended-number-set! n 1 ?arg1)
  58.               (begin (set! i (+ i 1))
  59.                  (extended-number-set! n i ?arg))
  60.               ...
  61.               n)))
  62.             (error "ill-formed DEFINE-EXTENDED-NUMBER-TYPE" '?type))))
  63.         (define (?predicate x)
  64.           (and (extended-number? x)
  65.            (eq? (extended-number-type x) ?type)))
  66.         (define-extended-number-accessors ?accessor ...)))))
  67.  
  68. (define-syntax define-extended-number-accessors
  69.   (syntax-rules ()
  70.     ((define-extended-number-accessors ?accessor)
  71.      (define (?accessor n) (extended-number-ref n 1)))
  72.     ((define-extended-number-accessors ?accessor1 ?accessor2)
  73.      (begin (define (?accessor1 n) (extended-number-ref n 1))
  74.         (define (?accessor2 n) (extended-number-ref n 2))))
  75.     ((define-extended-number-accessors ?accessor1 ?accessor2 ?accessor3)
  76.      (begin (define (?accessor1 n) (extended-number-ref n 1))
  77.         (define (?accessor2 n) (extended-number-ref n 2))
  78.         (define (?accessor3 n) (extended-number-ref n 3))))))
  79.  
  80. (define-method &type-priority ((t :extended-number-type))
  81.   (extended-number-type-priority t))
  82.  
  83. (define-method &type-predicate ((t :extended-number-type))
  84.   (extended-number-predicate t))
  85.  
  86.  
  87. ; Make all the numeric instructions be extensible.
  88.  
  89. (define-syntax define-opcode-extension
  90.   (syntax-rules ()
  91.     ((define-opcode-extension ?name ?table-name)
  92.      (begin (define ?table-name (make-method-table '?name))
  93.         (make-opcode-generic! (enum op ?name) ?table-name)))))
  94.  
  95.  
  96. (define-opcode-extension +              &+)
  97. (define-opcode-extension -              &-)
  98. (define-opcode-extension *              &*)
  99. (define-opcode-extension /              &/)
  100. (define-opcode-extension =              &=)
  101. (define-opcode-extension <              &<)
  102. (define-opcode-extension quotient       "ient)
  103. (define-opcode-extension remainder      &remainder)
  104.   
  105. (define-opcode-extension integer?       &integer?)
  106. (define-opcode-extension rational?      &rational?)
  107. (define-opcode-extension real?          &real?)
  108. (define-opcode-extension complex?       &complex?)
  109. (define-opcode-extension number?        &number?)
  110. (define-opcode-extension exact?         &exact?)
  111.  
  112. (define-opcode-extension exact->inexact &exact->inexact)
  113. (define-opcode-extension inexact->exact &inexact->exact)
  114. (define-opcode-extension real-part      &real-part)
  115. (define-opcode-extension imag-part      &imag-part)
  116.  
  117. (define-opcode-extension floor          &floor)
  118. (define-opcode-extension numerator      &numerator)
  119. (define-opcode-extension denominator    &denominator)
  120.  
  121. (define-opcode-extension make-rectangular &make-rectangular)
  122.  
  123. (define-opcode-extension exp  &exp)
  124. (define-opcode-extension log  &log)
  125. (define-opcode-extension sin  &sin)
  126. (define-opcode-extension cos  &cos)
  127. (define-opcode-extension tan  &tan)
  128. (define-opcode-extension asin &asin)
  129. (define-opcode-extension acos &acos)
  130. (define-opcode-extension atan &atan)
  131. (define-opcode-extension sqrt &sqrt)
  132.  
  133. ; Default methods.
  134.  
  135. (define-method &integer?  (x) #f)
  136. (define-method &rational? (x) (integer? x))
  137. (define-method &real?     (x) (rational? x))
  138. (define-method &complex?  (x) (real? x))
  139. (define-method &number?   (x) (complex? x))
  140.  
  141. (define-method &real-part ((x :real)) x)
  142.  
  143. (define-method &imag-part ((x :real))
  144.   (if (exact? x) 0 (exact->inexact 0)))
  145.  
  146. (define-method &floor ((n :integer)) n)
  147.  
  148. (define-method &numerator ((n :integer)) n)
  149.  
  150. (define-method &denominator ((n :integer))
  151.   (if (exact? n) 1 (exact->inexact 1)))
  152.  
  153. ; Make sure this has very low priority, so that it's only tried as a
  154. ; last resort.
  155.  
  156. (define-method &/ (m n)
  157.   (if (and (integer? m) (integer? n))
  158.       (if (= 0 (remainder m n))
  159.       (quotient m n)
  160.       (let ((z (abs (quotient n 2))))
  161.         (set-exactness (quotient (if (< m 0)
  162.                      (- m z)
  163.                      (+ m z))
  164.                      n)
  165.                #f)))
  166.       (next-method)))
  167.  
  168. (define-method &sqrt ((n :integer))
  169.   (if (>= n 0)
  170.       (non-negative-integer-sqrt n)    ;Dubious
  171.       (next-method)))
  172.  
  173. (define (non-negative-integer-sqrt n)
  174.   (cond ((<= n 1)    ; for both 0 and 1
  175.      n)
  176.     ;; ((< n 0)
  177.     ;;  (make-rectangular 0 (integer-sqrt (- 0 n))))
  178.     (else
  179.      (let loop ((m (quotient n 2)))
  180.        (let ((m1 (quotient n m)))
  181.          (cond ((< m1 m)
  182.             (loop (quotient (+ m m1) 2)))
  183.            ((= n (* m m))
  184.             m)
  185.            (else
  186.             (exact->inexact m))))))))
  187.  
  188. (define-simple-type :exact (:number)
  189.   (lambda (n) (and (number? n) (exact? n))))
  190.  
  191. (define-simple-type :inexact (:number)
  192.   (lambda (n) (and (number? n) (inexact? n))))
  193.  
  194.  
  195. ; Whattakludge.
  196.  
  197. ; Replace the default method (which in the initial image always returns #f).
  198.  
  199. (define-method &really-string->number (s radix xact?)
  200.   (let ((len (string-length s)))
  201.     (cond ((<= len 1) #f)
  202.       ((char=? (string-ref s (- len 1)) #\i)
  203.        (parse-rectangular s radix xact?))
  204.       ((string-position #\@ s)
  205.        => (lambda (at)
  206.         (let ((r (really-string->number (substring s 0 at)
  207.                         radix xact?))
  208.               (theta (really-string->number (substring s (+ at 1) len)
  209.                             radix xact?)))
  210.           (if (and (real? r) (real? theta))
  211.               (make-polar r theta)))))
  212.       ((string-position #\/ s)
  213.        => (lambda (slash)
  214.         (let ((m (string->integer (substring s 0 slash) radix))
  215.               (n (string->integer (substring s (+ slash 1) len)
  216.                       radix)))
  217.           (if (and m n)
  218.               (set-exactness (/ m n) xact?)
  219.               #f))))
  220.       ((string-position #\# s)
  221.        (if xact?
  222.            #f
  223.            (really-string->number
  224.            (list->string (map (lambda (c) (if (char=? c #\#) #\5 c))
  225.                       (string->list s)))
  226.            radix
  227.            xact?)))
  228.       ((string-position #\. s)
  229.        => (lambda (dot)
  230.         (parse-decimal s radix xact? dot)))
  231.       (else #f))))
  232.  
  233. (define (parse-decimal s radix xact? dot)
  234.   ;; Talk about kludges.  This is REALLY kludgey.
  235.   (let* ((len (string-length s))
  236.      (j (if (or (char=? (string-ref s 0) #\+)
  237.             (char=? (string-ref s 0) #\-))
  238.         1
  239.         0))
  240.      (m (if (= dot j)
  241.         0
  242.         (string->integer (substring s j dot)
  243.                  radix)))
  244.      (n (if (= dot (- len 1))
  245.         0
  246.         (string->integer (substring s (+ dot 1) len)
  247.                  radix))))
  248.     (if (and m n)
  249.     (let ((n (+ m (/ n (expt radix
  250.                  (- len (+ dot 1)))))))
  251.       (set-exactness (if (char=? (string-ref s 0) #\-)
  252.                  (- 0 n)
  253.                  n)
  254.              xact?))
  255.     #f)))
  256.  
  257. (define (parse-rectangular s radix xact?)
  258.   (let ((len (string-length s)))
  259.     (let loop ((i (- len 2)))
  260.       (if (< i 0)
  261.       #f
  262.       (let ((c (string-ref s i)))
  263.         (if (or (char=? c #\+)
  264.             (char=? c #\-))
  265.         (let ((x (if (= i 0)
  266.                  0
  267.                  (really-string->number (substring s 0 i)
  268.                             radix xact?)))
  269.               (y (if (= i (- len 2))
  270.                  (if (char=? c #\+) 1 -1)
  271.                  (really-string->number (substring s i (- len 1))
  272.                             radix xact?))))
  273.           (if (and (real? x) (real? y))
  274.               (make-rectangular x y)
  275.               #f))
  276.         (loop (- i 1))))))))
  277.  
  278. (define (set-exactness n xact?)
  279.   (if (exact? n)
  280.       (if xact? n (exact->inexact n))
  281.       ;; ?what to do? (if xact? (inexact->exact n) n)
  282.       n))
  283.  
  284. ; Utility
  285.  
  286. (define (string-position c s)
  287.   (let loop ((i 0))
  288.     (if (>= i (string-length s))
  289.     #f
  290.     (if (char=? c (string-ref s i))
  291.         i
  292.         (loop (+ i 1))))))
  293.